perm filename PTS.F4[MSS,LCS] blob
sn#148527 filedate 1975-02-28 generic text, type T, neo UTF8
00100 C THIS AIDS IN EXTRACTING PARTS FROM SCORES - OR PACKING OF .DAT
00200 C FILES FOR EASIER STORAGE.
00300 DIMENSION XN(2000),RSTFAC(8),IV(78),LIST(200),PWDS(250),RN(2000)
00400 1,XWDS(250),STFF(8)
00500 C**** RN MIGHT HAVE TO BE 4000 ******
00600 CC EQUIVALENCE (XN,IV),(XWDS,LIST)
00700
00800 14 JT=0
00900 JR=0
01800 REWIND 1
02000 1 FORMAT(' TYPE OUTPUT FILE NAME ',$)
02100 TYPE 1
02200 ACCEPT 2,NAME
02300 IF(LOOKD(NAME).GE.0)GO TO 13
02400 TYPE 88
02500 ACCEPT 2,L
02600 IF(L.EQ.'N')GO TO 14
02700 88 FORMAT(' WRITE OVER FILE???? '$)
02800 13 CALL OFILE(1,NAME)
02900 XWDS(1)=1
03000 RM=0
03100 L=1
03200 LX=1
03300 LP=1
03310 44 FORMAT(' TYPE TOP OUTPUT STAFF # ',$)
03400 TYPE 44
03500 ACCEPT 5,RS
03600 10 IF(JT.EQ.0)GO TO 83
03700 NAME=NAME+2
03800 GO TO 84
03900 86 FORMAT(1XA5)
03910 3 FORMAT(' TYPE INPUT NAME, (CONT), (NOBAR) ',$)
04000 83 TYPE 3
04100 ACCEPT 2,NAME,JT,NBAR
04200 C TYPE ANY NUMBER AFTER NAME AND IT WILL GO TO NEXT LETTER IN ALPH.
04250 IF(NBAR.NE.0)NBAR=-1
04275 C ANY THIRD NUM. SUPPRESSES SCORE BARLINE FEATURE
04300 84 LK=LP
04400 IF(LOOKD(NAME).GE.0)GO TO 20
04500 C FOUND NO MORE TO READ
04600 TYPE 86,NAME
04700 JZ=0
04800 IF(RM.NE.0)GO TO 77
04805 RM=-1
04810 4 FORMAT(' TYPE INST NAME -- '$)
04900 TYPE 4
05000 ACCEPT 2,RNAM
05100 IF(INM.EQ.'99')GO TO 20
05150 CC K=SN/100.
05160 TYPE 46
05170 46 FORMAT(' TRANS. NUM. -- '$)
05180 ACCEPT 5,TR
05190 IF(TR.GE.99)GO TO 83
05200 77 REWIND 21
05216 177 CALL IFILE(21,NAME)
05232 READ(21),ITEM,I,
05248 1 (PWDS(K),K=1,ITEM+1),(RN(K),K=1,I-1),ISCR,(IV(K),K=1,ISCR),
05264 1 LCNT,(LIST(K),K=1,LCNT),RSTFAC,STFF
05300 C TYPE 2ND NUM FOR TRANSPOSE, 3RD NUM FOR ALWAYS SAME STFF.
05310 DO 45 K=1,ITEM
05320 J=PWDS(K)
05330 IF(RN(J+1).NE.8)GO TO 45
05340 IF(RN(J+9).NE.RNAM)GO TO 45
05350 SN=RN(J+2)
05360 C FOUND THE STAFF
05370 GO TO 8
05380 45 CONTINUE
05382 L=JX
05384 LP=JY
05390 TYPE 16
05392 16 FORMAT(' STAFF NOT FOUND'/)
05395 GO TO 10
05400 8 DO 6 K=1,ITEM
05500 J=PWDS(K)
05600 IF(RN(J+1).NE.4.OR.NBAR)GO TO 80
05700 IF(RN(J).NE.2)GO TO 80
05800 C FOUND A BAR LINE
05810 KB=RN(J+4)/100.
05900 RN(J+4)=1.+KB*100.
05910 C KB IS FOR THICK BARS.
06000 R=RN(J+3)
06100 DO 82 KA=K+1,ITEM
06200 KB=PWDS(KA)
06300 IF(RN(KB+1).NE.4.OR.RN(KB).NE.2)GO TO 82
06400 C AVOIDS DUPLICATE BARS.
06500 IF(ABS(R-RN(KB+3)).GT..5)GO TO 82
06600 RN(KB+2)=99
06700 RN(KB+1)=0
06800 82 CONTINUE
06900 GO TO 81
07000 80 IF(RN(J+2).NE.SN)GO TO 6
07100 IF(RN(J+1).NE.8)GO TO 81
07200 IF(RN(J).LT.3)GO TO 81
07300 RN(J+4)=0
07400 C SETS VERT. POS. OF STAFF TO 0. WHAT ABOUT P5??!
07500 CC85 JZ=-1
07600 81 JA=PWDS(K+1)
07700 DO 7 KA=J,JA-1
07800 XN(LK)=RN(KA)
07900 7 LK=LK+1
08000 IF(L.LT.250.AND.LK.LE.2000)GO TO 50
08100 TYPE 9
08200 GO TO 20
08400 50 R=XN(LP+1)
08500 IF(TR.NE.0.AND.(R.EQ.1.OR.R.EQ.5.OR.R.EQ.6))GO TO 52
08600 51 XN(LP+2)=RS
08700 L=L+1
08800 LP=LK
08900 XWDS(L)=LP
09000 6 CONTINUE
09600 17 JX=L
09700 JY=LP
09800 RS=RS-1
09810 C******↓↓↓↓↓↓ RHYTH RESET ↓↓↓↓↓↓↓↓
09900 M=LX+1
10000 J=XWDS(LX)
10100 PWDS(LX)=XWDS(LX)
10200 I=LX
10400 24 RA=10000.
10500 C POSITION
10700 DO 21 K=LX,L-1
10750 JL=XWDS(K)+3
10800 R=XN(JL)
10810 IF(R.EQ.10000)GO TO 21
10820 IF(ABS(R-RA).GT..1)GO TO 240
10830 R=RA
10840 XN(JL)=R
10850 C PUT IN HERE MULTI-VOICE TRAP
10860 GO TO 21
10900 240 IF(R.GT.RA)GO TO 21
10975 C LINES THEM UP
11000 I=K
11100 RA=R
11200 21 CONTINUE
11300 IF(RA.EQ.10000)GO TO 23
11400 C JUMP IF ALL SORTED
11500 JL=XWDS(I)
11600 LA=JL
11700 N=XN(JL)+3
11800 C NEXT POINTER
11900 PWDS(M)=PWDS(M-1)+N
12000 M=M+1
12100 DO 22 K=J,J+N-1
12200 RN(K)=XN(JL)
12300 22 JL=JL+1
12400 XN(LA+3)=10000
12500 C PUT IT ASIDE
12600 J=N+J
12700 GO TO 24
12750
12800 23 LB=LX
12900 25 N=PWDS(LB)
13000 R=RN(N+1)
13100 IF(R.GT.2.OR.(R.EQ.1.AND.RN(N).LT.7))GO TO 30
13200 C LOOK ONLY AT NOTES AND RESTS AND NON-DOUBLE STOPS
13250 S=RN(N+3)
13300 LA=LB
13400 26 LA=LA+1
13450 IF(LA.GE.L)GO TO 30
13500 C FIND NEXT IMPORTANT ITEM
13600 NA=PWDS(LA)
13700 A=RN(NA+1)
13800 IF(A.GT.4.OR.(A.EQ.4.AND.RN(NA).NE.2))GO TO 26
13900 C USES ONLY NOTES, RESTS, BARS, CLEFS
14000 34 RX=RN(NA+3)
14100 C POSITION OF NEXT ITEM
14150 IF(S.EQ.RX)GO TO 26
14160 A=RX-2
14170 IF(A.LT.S)A=S+.5
14180 C SPACING WILL BEGIN NEARBY
14200 K=9
14300 IF(R.EQ.2)K=7
14400 P=RN(N+K)*10.
14500 C FINDS RHYTH IN P9 OR P7(REST)
14550 C IF DIFFERENT SIMULTANEOUS RHYTHMS, ZERO OUT LARGER BEFORE HAND.
14600 IF(P)GO TO 30
14610 C SKIPS NOTES WITH SUPPRESSED LEDGER LINES.
14800 SX=S+P-RX
14900 C SPACE DIFFERENCE
15000 35 DO 29 K=LX,L-1
15100 NZ=PWDS(K)+3
15110 RA=RN(NZ)
15200 IF(RA.GT.A)RN(NZ)=RA+SX
15201 C A=BASIC POS. AT THIS TIME.
15202 R=RN(NZ-2)
15205 IF(R4567(R))GO TO 29
15207 NZ=NZ-3
15210 IF(RN(NZ).EQ.2)GO TO 29
15212 RB=RN(NZ+6)
15215 IF(RB.GT.A)RN(NZ+6)=RB+SX
15220 IF(RN(NZ).LT.7)GO TO 29
15225 C FOR IRREGULAR BEAMS
15227 RB=RN(NZ+9)
15230 IF(RB.GT.A)RN(NZ+9)=RB+SX
15232 RB=RN(NZ+8)
15235 IF(RB.GT.A.AND.RN(NZ).GT.8.AND.RN(NZ+10).GE.30)RN(NZ+8)=RB+SX
15240 29 CONTINUE
15300 30 LB=LB+1
15400 IF(LB.LT.L)GO TO 25
15500 C GO BACK IF MORE SPACING TO DO
15600 SX=200./RN(IFIX(PWDS(L-1)+3))
15700 C `SHRINK' FACTOR
15800 DO 31 K=LX,L-1
15900 N=PWDS(K)+3
15901 RN(N)=RN(N)*SX
15902 R=RN(N-2)
15905 IF(R4567(R))GO TO 31
15907 N=N-3
15910 IF(RN(N).EQ.2)GO TO 31
15915 RB=RN(N+6)
15920 RN(N+6)=RB*SX
15925 IF(RN(N).LT.7)GO TO 31
15930 C FOR IRREGULAR BEAMS
15935 RB=RN(N+9)
15940 RN(N+9)=RB*SX
15945 RB=RN(N+8)
15950 IF(RN(N).GT.8.AND.RN(N+10).GE.30)RN(N+8)=RB*SX
16050 31 CONTINUE
16100 DO 32 K=IFIX(PWDS(LX)),IFIX(PWDS(L))
16200 32 XN(K)=RN(K)
16300 DO 33 K=LX,L
16400 33 XWDS(K)=PWDS(K)
16500 C ALL DONE
16550 C****↑↑↑↑↑↑ RHYTH. RESET ↑↑↑↑↑↑↑↑↑↑↑
16600 LX=L
16700
16800 IF(RS.GT.-4)GO TO 10
16900 20 L=JX-1
17000 J=1
17100 WRITE(1),L,JY,
17200 1 (XWDS(K),K=1,L+1),(XN(K),K=1,JY-1),J,J,J,J,RSTFAC,STFF,J
17300 15 END FILE 1
17400 CALL EXIT
17600 2 FORMAT(A5,2I)
17900 5 FORMAT(5F)
18000 9 FORMAT(' NO ROOM FOR THIS ONE')
18200
30400
30500 52 A=XN(LP+4)
30600 XN(LP+4)=A+TR
30700 C TRANSPOSES ONLY BY STAFF STEPS FOR NOW
30800 X=XN(LP+5)
30900 IF(XN(LP+1).EQ.1)GO TO 11
31000 XN(LP+5)=X+TR
31100 GO TO 51
31200 11 IF(TR.EQ.4.AND.AMOD(A,7.0).EQ.0)GO TO 101
31300 IF(AMOD(TR-1.0,7.0).NE.0)GO TO 51
31400 C NEXT IS FOR Bb TRANSP.
31500 B=AMOD(A+7.0,7.0)
31600 IF(B.NE.0.AND.B.NE.3)GO TO 51
31700 C FINDS ORIG. E OR B
31800 101 M=AMOD(X,10.0)
31900 C FINDS ACCID.
32000 X=X-M
32100 C STEM DIR. AND DECI.
32200 B=3.
32300 C CHANGES FLAT TO NATURAL SIGN.
32400 IF(M.EQ.0.OR.M.EQ.3)B=2
32500 C NO PROVISION YET FOR ## OR bb
32600 XN(LP+5)=X+B
32700 GO TO 51
32800 END
32900
33000 FUNCTION R4567(R)
33100 R4567=0
33200 IF(R.LT.4)GO TO 1
33250 IF(R.LE.7)RETURN
33287 1 R4567=-1
33300 END